;;;; This file contains code in Chapter 4 of ACL
;;;This is the Binary Search function described on page 60.
(defun bin-search (obj vec)
  (let ((len (length vec)))
    (and (not (zerop len))
      (finder obj vec 0 (- len 1)))))

(defun finder (obj vec start end)
  (let ((range (- end start)))
    (if (zerop range)
      (if (eql obj (aref vec range))
	  obj
	  nil)
      (let ((mid (+ start (round (/ range 2)))))
	(let ((obj2 (aref vec mid)))
	  (if (< obj obj2)
	      (finder obj vec start (- mid 1))
	      (if (> obj obj2)
		  (finder obj vec (+ mid 1) end)
		  obj)))))));

;;;This function is taken from Page 63 from ACL
(defun mirror? (s)
  (let ((len (length s)))
    (and (evenp len)
	 (do ((forward 0 (+ forward 1))
	      (back (- len 1) (- back 1)))
	     ((or (> forward back)
		  (not (eql (elt s forward)
			    (elt s back))))
	      (> forward back))))))


;;;This fuction is taken from page 67 of ACL. 
(defun tokens (str test start)
  (let ((p1 (position-if test str :start start)))
    (if p1 
	(let ((p2 (position-if #'(lambda (c)
				   (not (funcall test c)))
			       str :start p1)))
	  (cons (subseq str p1 p2)
		(if p2 
		    (tokens str test p2)
		    nil)))
	nil)))


(defun constituents (c)
  (and (graphic-char-p c)
       (not (char= c #\ ))))

(defun parse-date (str)
  (let ((toks (tokens str #'constituents 0)))
    (list (parse-integer (first toks))
	  (parse-month (second toks))
	  (parse-integer (third toks)))))

(defconstant month-names 
  #("jan" "feb" "mar" "apr" "may" "jun" "jul" "aug" "sep" "oct" "nov" "dec"))

(defun parse-month (month)
  (let ((p (position month month-names :test #'string-equal)))
    (if p 
	(+ p 1)
	nil)))

(defun read-integer (str)
  (if (every #'digit-char-p str)
      (let ((num 0))
	(dotimes (p (length str))
	  (setf num (+ (* num 10)
		       (digit-char-p (char str p)))))
	num)
      nil))


;;; This program is taken from ACL page 73.
(defstruct (node (:print-function 
		  (lambda (n s d)
		    (format s "#<~A>" (node-elt n)))))
	   elt (l nil) (r nil))


(defun bst-insert (obj bst <)
  (if (null bst)
      (make-node :elt obj)
      (let ((elt (node-elt bst)))
	(if (eql elt obj)
	    bst
	    (if (funcall < obj elt)
		(make-node 
		 :elt elt
		 :l (bst-insert obj (node-l bst) <)
		 :r (node-r bst))
		(make-node 
		 :elt elt
		 :l (node-l bst)
		 :r (bst-insert obj (node-r bst) <)))))))


(defun bst-find (obj bst <)
  (if (null bst)
      nil
      (let ((elt (node-elt bst)))
	(if (eql obj elt)
	    bst
	    (if (funcall < obj elt)
		(bst-find obj (node-l bst) <)
		(bst-find obj (node-r bst) <))))))

(defun bst-min (bst)
  (and bst
       (or (bst-min (node-l bst)) bst)))

(defun bst-max (bst)
  (and bst
       (or (bst-max (node-r bst)) bst)))

(defun bst-remove (obj bst <)
  (if (null bst)
      nil
      (let ((elt (node-elt bst)))
	(if (eql elt obj)
	    (percolate bst)
	    (if (funcall < obj elt)
		(make-node 
		 :elt elt
		 :l (bst-remove obj (node-l bst) <)
		 :r (node-r bst))
		(make-node
		 :elt elt
		 :l (node-l bst)
		 :r (bst-remove obj (node-r bst) <)))))))

(defun percolate (bst)
  (cond ((null (node-l bst))
	 (if (null (node-r bst))
	     nil
	     (rperc bst)))
	((null (node-r bst)) (lperc bst))
	(t (if (zerop (random 2 ))
	       (lperc bst)
	       (rperc bst)))))

(defun rperc (bst)
  (make-node :elt (node-elt (node-r bst))
	     :l (node-l bst)
	     :r (percolate (node-r bst))))

(defun lperc (bst)
  (make-node :elt (node-elt (node-l bst))
	     :l (percolate (node-l bst))
	     :r (node-r bst)))

(defun bst-traverse (fn bst)
  (when bst 
    (bst-traverse fn (node-l bst))
    (funcall fn (node-elt bst))
    (bst-traverse fn (node-r bst))))


;;;; Following code has been taken from ACL Chapter 5. 
(defun check-month (mon)
  (case mon 
    ((jan mar may jul aug oct dec) 31)
    ((apr jun sep nov) 30)
    (feb (if (leap-year) 29 28))
    (otherwise "invalid month")))



;;; The following example is taken from chapter 5 page 93 and 94. 
(defconstant *month-day* 
  '(31 28 31 30 31 30 31 31 30 31 30 31))
(defconstant month 
  (make-array 13 
	      :initial-contents 	      		    
		    (let ((x (reverse (maplist #'(lambda (x)
					   (apply #'+ x))
				       (reverse *month-day*)))))
		      (push 0 x))))
		     

(defconstant yzero 2000)

(defun leap? (y)
  (and (zerop (mod y 4))
       (or (zerop (mod y 400))
	   (not (zerop (mod y 100))))))

(defun date->num (d m y)
  (+ (- d 1) (month-num m y) (year-num y)))

(defun month-num (m y)
  (+ (svref month (- m 1))
     (if (and (> m 2) 
	      (leap? y))
	 1
	 0)))

(defun year-num (y)
  (let ((d 0))
    (if (> y yzero)
	(dotimes (i (- y yzero) d)
	  (incf d (year-days (+ yzero i))))
	(dotimes (i (- yzero y) (- d))
	  (incf d (year-days (- yzero i)))))))

(defun year-days (y)
  (if (leap? y) 366 365))

(defun num-month (n y)
  (if (leap? y)
      (cond ((= n 59) (values 2 29))
	    ((> n 59) (nmon (- n 1)))
	    (t (nmon n)))
      (nmon n)))

(defun nmon (n)
  (let ((m (position n month :test #'<)))
    (values m (+ 1 (- n (svref month (- m 1)))))))

(defun num-year (n)
  (if (< n 0)
      (do* ((y (- yzero 1) (- y 1))
	    (d (- (year-days y)) (- d (year-days y))))
	    ((<= d n) (values y (- n d))))
      (do* ((y yzero (+ y 1))
	    (prev 0 d)
	    (d (year-days y) (+ d (year-days y))))
	   ((> d n) (values y (- n prev))))))

(defun num->date (n)
  (multiple-value-bind (y left) (num-year n)
    (multiple-value-bind (m d) (num-month left y)
      (values d m y))))

;;;;Taken from page 122 from Input and Output chapter
(defun pseudo-cat (file)
  (with-open-file (str file :direction :input)
    (do ((line (read-line str nil 'eof)
	       (read-line str nil 'eof)))
	((eql line 'eof) 'done)
      (format t "~A~%" line))))

;;; taken from page 127 of ACL

(defstruct buf
  vec (start -1) (end -1) (new -1) (used -1))

(defun bref (buf n)
  (svref (buf-vec buf)
	 (mod n (length (buf-vec buf)))))

(defun (setf bref) (val buf n)
  (setf (svref (buf-vec buf)
	       (mod n (length (buf-vec buf))))
	val))

(defun new-buf (len)
  (make-buf :vec (make-array len)))

(defun buf-insert (x b)
  (setf (bref b (incf (buf-end b))) x))

(defun buf-pop (b)
  (prog1 
    (bref b (incf (buf-start b)))
    (setf (buf-used b) (buf-start b)
	  (buf-new b) (buf-end b))))

(defun buf-next (b)
  (when (< (buf-used b) (buf-new b))
    (bref b (incf (buf-used b)))))

(defun buf-reset (b)
  (setf (buf-used b) (buf-start b)
	(buf-new b) (buf-end b)))

(defun buf-flush (b str)
  (do ((i (1+ (buf-used b)) (1+ i)))
      ((> i (buf-end b)))
    (princ (bref b i) str)))
    
(defun buf-clear (b)
  (setf (buf-start b) -1
	(buf-end b) -1
	(buf-used b) -1
	(buf-new b) -1))

(defun file-subst (old new file1 file2)
  (with-open-file (in file1 :direction :input)
    (with-open-file (out file2 :direction :output
			 :if-exists :supersede)
    (stream-subst old new in out))))

(defun stream-subst (old new in out)
  (let* ((pos 0)
	 (len (length old))
	 (buf (new-buf len))
	 (from-buf nil))
    (do ((c (read-char in nil :eof)
	    (or (setf from-buf (buf-next buf))
		(read-char in nil :eof))))
	((eql c :eof))
      (cond ((or (char= (char old pos) #\+) 
		 (char= c (char old pos)))
	     (incf pos)
	     (cond ((= pos len)
		    (princ new out)
		    (setf pos 0)
		    (buf-clear buf))
		   ((not from-buf)
		    (buf-insert c buf))))
	    ((zerop pos)
	     (princ c out)
	     (when from-buf
	       (buf-pop buf)
	       (buf-reset buf)))
	    (t 
	     (unless from-buf
	       (buf-insert c buf))
	     (princ (buf-pop buf) out)
	     (buf-reset buf)
	     (setf pos 0))))
    (buf-flush buf out)))

;;;henley program code taken from page 140

(defparameter *words* (make-hash-table :size 100000))

(defconstant maxword 100)

(defun read-text (pathname)
  (with-open-file (s pathname :direction :input)
    (let ((buffer (make-string maxword))
	  (pos 0))
      (do ((c (read-char s nil :eof)
	      (read-char s nil :eof)))
	  ((eql c :eof))
	(if (or (alpha-char-p c) (char= c #\'))
	    (progn
	      (setf (aref buffer pos) c)
	      (incf pos))
	    (progn 
	      (unless (zerop pos)
		(see (intern (string-downcase 
			      (subseq buffer 0 pos))))
		(setf pos 0))
	      (let ((p (punc c)))
		(if p (see p)))))))))


(defun punc (c)
  (case c
    (#\. '|.|) (#\, '|,|)
    (#\; '|;|) (#\! '|!|)
    (#\? '|?|)))

(let ((prev '|.|))
  (defun see (symb)
    (let ((pair (assoc symb (gethash prev *words*))))
      (if (null pair)
	  (push (cons symb 1) (gethash prev *words*))
	  (incf (cdr pair))))
    (setf prev symb)))
	    
	    

(defun generate-text (n &optional (prev '|.|))
  (if (zerop n)
      (terpri)
      (let ((next (random-next prev)))
	(format t "~A " next)
	(generate-text (1- n) prev))))

(defun random-next (prev)
  (let* ((choices (gethash prev *words*))
	 (i (random (reduce #'+ choices 
			    :key #'cdr))))
    (dolist (pair choices)
      (if (minusp (decf i (cdr pair)))
	  (return (car pair))))))
		  

;;;;Ray tracing from page 152 from ACL

(defun sq (x)
  (* x x))

(defun mag (x y z)
  (sqrt (+ (sq x) (sq y) (sq z))))

(defun unit-vector (x y z)
  (let ((d (mag x y z)))
    (values (/ x d) (/ y d) (/ z d))))

(defstruct (point :conc-name nil)
  x y z)

(defun distance (p1 p2)
  (mag (- (x p1) (x p2))
       (- (y p1) (y p2))
       (- (z p1) (z p2))))

(defun minroot (a b c)
  (if (zerop a)
      (/ (- c) b)
      (let ((disc (- (sq b) (* 4 a c))))
	(unless (minusp disc)
	  (let ((discrt (sqrt disc)))
	    (min (/ (+ (- b) discrt) (* 2 a))
		 (/ (- (- b) discrt) (* 2 a))))))))

(defstruct surface color)

;;;;Page 200 from ACL 

(defun make-queue ()
  (cons nil nil))

(defun enqueue (q x)
  (let ((c (cons x nil))
        (back (cdr q))
        (front (car q)))
     (if (consp back)
	 (setf (cdr back) c) 
	 (setf (car q) c))
     (setf (cdr q) c))) 

(defun dequeue (q)
  (let ((l (car q)))
    (setf (car q) (cdr l))
    (car l)))


;;;;Doubly-linked list example from page 206.


;;;;Macros - Page 164
(defmacro while (test &rest body)
  `(do ()
       ((not ,test))
    ,@body))

(let ((x 0))
  (while (< x 10)
    (princ x)
    (incf x)))
